home *** CD-ROM | disk | FTP | other *** search
/ EnigmA Amiga Run 1996 June / EnigmA AMIGA RUN 08 (1996)(G.R. Edizioni)(IT)[!][issue 1996-06][EARSAN CD VII].iso / earcd / arexx / wac.lha / WAC next >
Text File  |  1996-05-10  |  25KB  |  545 lines
  1. /* What?! Another Calendar?! Version 1.03 */
  2. /* Copyright © Michael Tanzer 1993, 1996 */
  3. /* See additional notices in accompanying documentation */
  4.  
  5. blanks = 0 /* Number of blank lines at the top of the window.   */
  6.            /* If you use a screen text font that is larger than */
  7.            /* 9 pixels in height, you may need to increase this */
  8.            /* value (by 1 or 2) for cosmetic purposes.          */
  9.  
  10. /* Run WAC asynchronously */
  11. w = getclip('WAC')
  12. if w~=1 then do
  13.   call setclip('WAC',1)
  14.   address arexx 'WAC'
  15.   exit
  16.   end
  17. call setclip('WAC')
  18.  
  19. /* Make sure the necessary functions are available */
  20. if ~show('l','rexxsupport.library') then
  21.   call addlib('rexxsupport.library',0,-30)
  22. if ~show('l','rexxarplib.library') then
  23.   call addlib('rexxarplib.library',0,-30)
  24. signal on syntax
  25.  
  26. /* Insure only one copy of WAC is running */
  27. if showlist('p','WAC') then do
  28.   address 'WAC' 'closewindow'
  29.   call delay(50)
  30.   end
  31. if showlist('p','WACCTL') then call exit('WACCTL')
  32.  
  33. /* Set some rather important variables */
  34. mode = 'M'            /* Display mode  */
  35. cfgfile = 'S:WAC.config'
  36.  
  37. idcmp = 'closewindow+gadgetup+menupick'
  38. flags = 'windowclose+windowdrag+windowdepth'
  39.  
  40. xchar  = 8            /* Pixels / col  */
  41. ychar  = 9            /* Pixels / row  */
  42. yoff   = ychar*blanks /* Blank lines   */
  43. xminb  = 20           /* 1st x pixel   */
  44. yminbm = 36+yoff      /* 1st y (month) */
  45. yminby = 45+yoff      /* 1st y (year)  */
  46. hlsw = 0              /* No highlight  */
  47.  
  48. heading = 'Mo Tu We Th Fr Sa Su'
  49. dstring = ' 1  2  3  4  5  6  7  8  9 10 ' ||,
  50.           '11 12 13 14 15 16 17 18 19 20 ' ||,
  51.           '21 22 23 24 25 26 27 28 29 30 31'
  52.  
  53.                      /* Month mode    */
  54. wxm = 0              /* Window left   */
  55. wym = 0              /* Window top    */
  56. wwm = 200            /* Window width  */
  57. whm = 94+yoff        /* Window height */
  58. mlx = 7              /* MLESS left    */
  59. mly = 14+yoff        /* MLESS top     */
  60. mrx = 24             /* MSTRG left    */
  61. mry = 14+yoff        /* MSTRG top     */
  62. mrw = 74             /* MSTRG width   */
  63. mmx = 103            /* MMORE left    */
  64. mmy = 14+yoff        /* MMORE top     */
  65. ylxm = 125           /* YLESS left    */
  66. ylym = 14+yoff       /* YLESS top     */
  67. yrxm = 142           /* YSTRG left    */
  68. yrym = 14+yoff       /* YSTRG top     */
  69. yrwm = 34            /* YSTRG width   */
  70. ymxm = 181           /* YMORE left    */
  71. ymym = 14+yoff       /* YMORE top     */
  72.                      /* Year mode     */
  73. wxy = 0              /* Window left   */
  74. wyy = 0              /* Window top    */
  75. wwy = 568            /* Window width  */
  76. why = 346+yoff       /* Window height */
  77. ylxy = 251           /* YLESS left    */
  78. ylyy = 14+yoff       /* YLESS top     */
  79. yrxy = 268           /* YSTRG left    */
  80. yryy = 14+yoff       /* YSTRG top     */
  81. yrwy = 34            /* YSTRG width   */
  82. ymxy = 307           /* YMORE left    */
  83. ymyy = 14+yoff       /* YMORE top     */
  84.  
  85. /* Build some tables */
  86. mo_days.1  = 31      /* Days in month */
  87. mo_days.2  = 28
  88. mo_days.3  = 31
  89. mo_days.4  = 30
  90. mo_days.5  = 31
  91. mo_days.6  = 30
  92. mo_days.7  = 31
  93. mo_days.8  = 31
  94. mo_days.9  = 30
  95. mo_days.10 = 31
  96. mo_days.11 = 30
  97. mo_days.12 = 31
  98.  
  99. mo_prev.1 = 0        /* Days preceding month */
  100. do month = 2 to 12
  101.   w = month-1
  102.   mo_prev.month = mo_prev.w+mo_days.w
  103.   end
  104.  
  105. mo_name.1  = 'January'
  106. mo_name.2  = 'February'
  107. mo_name.3  = 'March'
  108. mo_name.4  = 'April'
  109. mo_name.5  = 'May'
  110. mo_name.6  = 'June'
  111. mo_name.7  = 'July'
  112. mo_name.8  = 'August'
  113. mo_name.9  = 'September'
  114. mo_name.10 = 'October'
  115. mo_name.11 = 'November'
  116. mo_name.12 = 'December'
  117.  
  118. mo_x.1  = 0          /* X offset for month */
  119. mo_x.2  = 1*23*xchar
  120. mo_x.3  = 2*23*xchar
  121. mo_x.4  = 0
  122. mo_x.5  = 1*23*xchar
  123. mo_x.6  = 2*23*xchar
  124. mo_x.7  = 0
  125. mo_x.8  = 1*23*xchar
  126. mo_x.9  = 2*23*xchar
  127. mo_x.10 = 0
  128. mo_x.11 = 1*23*xchar
  129. mo_x.12 = 2*23*xchar
  130.  
  131. mo_y.1  = 0          /* Y offset for month */
  132. mo_y.2  = 0
  133. mo_y.3  = 0
  134. mo_y.4  = 1*9*ychar
  135. mo_y.5  = 1*9*ychar
  136. mo_y.6  = 1*9*ychar
  137. mo_y.7  = 2*9*ychar
  138. mo_y.8  = 2*9*ychar
  139. mo_y.9  = 2*9*ychar
  140. mo_y.10 = 3*9*ychar
  141. mo_y.11 = 3*9*ychar
  142. mo_y.12 = 3*9*ychar
  143.  
  144. /* Read config file */
  145. w = open('input',cfgfile,'r')             /* Open config file as input   */
  146. if w=1 then do                            /* Proceed if file found       */
  147.   w = readln('input')                     /*   Read 1st record           */
  148.   do while ~eof('input')                  /*   Loop through rest of file */
  149.     interpret w                           /*     Interpret this record   */
  150.     w = readln('input')                   /*     Read next record        */
  151.     end
  152.   call close 'input'                      /*   Close config file         */
  153.   end
  154. mode = upper(mode)                        /* Force upper case            */
  155.  
  156. /* Set up host environment, window, etc. */
  157. call reset                                /* Establish current date      */
  158. call openport('WAC')                      /* Open notify port            */
  159. address arexx "'call createhost(WACCTL,WAC)'"/* Open control port        */
  160. address command 'WAITFORPORT WACCTL'      /* Note: fall through on error */
  161. call openw                                /* Go open new window          */
  162. flags = flags'+activate'                  /* Adjust for mode changes     */
  163.  
  164. /* Main control loop */
  165. halt: do forever                          /* Top of main control loop    */
  166.   signal on halt                          /* HI causes return to top     */
  167.   trace 'b'                               /* Continue in spite of TS     */
  168.   call waitpkt('WAC')                     /* Wait for some action        */
  169.   pkt = getpkt('WAC')                     /* Retrieve packet             */
  170.   if pkt=='00000000'x then iterate        /* Caused by TS                */
  171.   message = getarg(pkt)                   /* Retrieve message            */
  172.   call reply(pkt,0)                       /* Acknowledge message         */
  173.   action = upper(word(message,1))         /* Isolate 1st word of msg     */
  174.   select                                  /* Respond as required         */
  175.     when action=='QUIT' then leave        /* QUIT chosen from menu       */
  176.     when action=='CLOSEWINDOW' then leave /* Window closed               */
  177.     when action=='RESET' then do          /* RESET chosen from menu      */
  178.       call reset                          /*   Re-establish current date */
  179.       call newyear                        /*   Re-write year gadget      */
  180.       call newmonth                       /*   Re-write month gadget     */
  181.       end /* RESET */
  182.     when action=='MLESS' then do          /* MONTH LESS gadget           */
  183.       month = month-1                     /*   Decrement month           */
  184.       if month<1 then do                  /*   If <January,              */
  185.         month = 12                        /*     Use December            */
  186.         if year>1900 then do              /*     If not minimum year,    */
  187.           year = year-1                   /*       Decrement year        */
  188.           call newyear                    /*       Re-write year gadget  */
  189.           end
  190.         end
  191.       call newmonth                       /*   Re-write month gadget     */
  192.       end /* MLESS */
  193.     when action=='MSTRG' then do          /* MONTH STRING gadget         */
  194.       w = substr(word(message,2),1,1)     /*   Get 1st char              */
  195.       if w=='+' | w=='-' then do          /*   Relative reset            */
  196.         call relative                     /*     Go determine new date   */
  197.         if result=0 then do               /*     Handle invalid request  */
  198.           call newmonth                   /*       Re-write month gadget */
  199.           iterate                         /*       That's all            */
  200.           end
  201.         call newmonth                     /*     Re-write month gadget   */
  202.         call newyear                      /*     Re-write year gadget    */
  203.         call mdates                       /*     Fill in dates for month */
  204.         iterate                           /*     All done                */
  205.         end
  206.      reqmm = upper(word(message,2))       /*   Get desired month         */
  207.       if length(reqmm)>0 then do          /*     Got a desired month     */
  208.         if datatype(reqmm,'w') & reqmm>=1 & reqmm<=12 then month = reqmm+0
  209.         else do w = 1 to 12               /*     Find month in table     */
  210.           if abbrev(upper(mo_name.w),reqmm) then do  /* If match found,  */
  211.             month = w                     /*       Use new month         */
  212.             leave                         /*       Don't check others    */
  213.             end
  214.           end
  215.         w = word(message,3)               /*     Got a date?             */
  216.         if datatype(w,'w') & w>0 then do  /*     Yes, check it           */
  217.           if w<=mo_days.month | (year//4=0 & month=2 & w=29) then do
  218.             day = w                       /*       Set new day           */
  219.             thisday = day                 /*       Day becomes current   */
  220.             thismonth = month             /*       Month becomes current */
  221.             thisyear = year               /*       year becomes current  */
  222.             call removehl                 /*       Remove highlight      */
  223.             end
  224.           end
  225.         end
  226.       call newmonth                       /*   Re-write month gadget     */
  227.       end /* MSTRG */
  228.     when action=='MMORE' then do          /* MONTH MORE gadget           */
  229.       month = month+1                     /*   Increment month           */
  230.       if month>12 then do                 /*   If >December,             */
  231.         month = 1                         /*     Use January             */
  232.         if year<2099 then do              /*     If not maximum year,    */
  233.           year = year+1                   /*       Increment year        */
  234.           call newyear                    /*       Re-write year gadget  */
  235.           end
  236.         end
  237.       call newmonth                       /*   Re-write month gadget     */
  238.       end /* MMORE */
  239.     when action=='YLESS' then do          /* YEAR LESS gadget            */
  240.       if year>1900 then do                /*   If not minimum year,      */
  241.         year = year-1                     /*     Decrement year          */
  242.         call newyear                      /*     Re-write year gadget    */
  243.         end
  244.       end /* YLESS */
  245.     when action=='YSTRG' then do          /* YEAR STRING gadget          */
  246.       reqyy = word(message,2)             /*   Get desired year          */
  247.       if datatype(reqyy,'w') & reqyy>=1900 & reqyy<=2099 then year = reqyy
  248.       call newyear                        /*   Re-write year gadget      */
  249.       end /* YSTRG */
  250.     when action=='YMORE' then do          /* YEAR MORE gadget            */
  251.       if year<2099 then do                /*   If not maximum year,      */
  252.         year = year+1                     /*     Increment year          */
  253.         call newyear                      /*     Re-write year gadget    */
  254.         end
  255.       end /* YMORE */
  256.     when action=='MMODE' then do          /* MONTH MODE chosen from menu */
  257.       if mode=='Y' then do                /*   Check for year mode       */
  258.         if words(message)>2 then do       /*   Check for window position */
  259.           wxy = word(message,2)           /*     Save year window x      */
  260.           wyy = word(message,3)           /*     Save year window y      */
  261.           end
  262.         call closewindow('WACCTL','continue')/*  Close year window       */
  263.         mode = 'M'                        /*   Change mode to month      */
  264.         call openw                        /*   Go open new window        */
  265.         iterate                           /*   Bypass call to mdates     */
  266.         end
  267.       end /* MMODE */
  268.     when action=='YMODE' then do          /* YEAR MODE chosen from menu  */
  269.       if mode=='M' then do                /*   Check for month mode      */
  270.         if words(message)>2 then do       /*   Check for window position */
  271.           wxm = word(message,2)           /*     Save month window x     */
  272.           wym = word(message,3)           /*     Save month window y     */
  273.           end
  274.         call closewindow('WACCTL','continue')/*  Close month window      */
  275.         mode = 'Y'                        /*   Change mode to year       */
  276.         call openw                        /*   Go open new window        */
  277.         iterate                           /*   Bypass call to ydates     */
  278.         end
  279.       end /* YMODE */
  280.     when action=='SPREF' then do          /* SAVE PREFS chosen from menu */
  281.       if words(message)>2 then do         /*   Check for window position */
  282.         if mode=='M' then do              /*     If in month mode,       */
  283.           wxm = word(message,2)           /*       Save month window x   */
  284.           wym = word(message,3)           /*       Save month window y   */
  285.           end
  286.         else do                           /*     If in year mode,        */
  287.           wxy = word(message,2)           /*       Save year window x    */
  288.           wyy = word(message,3)           /*       Save year window y    */
  289.           end
  290.         end
  291.       w = statef(cfgfile)                 /*   See if cfg file exists    */
  292.       if w='' then call delete cfgfile    /*   If so, delete it          */
  293.       call open 'output',cfgfile,'w'      /*   Open config file as output*/
  294.       if result then do                   /*   Proceed if open ok        */
  295.         w = 'mode =' mode                 /*     Display mode            */
  296.         call writeln 'output',w
  297.         w = 'wxm =' wxm                   /*     Window left   (month)   */
  298.         call writeln 'output',w
  299.         w = 'wym =' wym                   /*     Window top    (month)   */
  300.         call writeln 'output',w
  301.         w = 'wxy =' wxy                   /*     Window left   (year)    */
  302.         call writeln 'output',w
  303.         w = 'wyy =' wyy                   /*     Window top    (year)    */
  304.         call writeln 'output',w
  305.         call close 'output'               /*     Close output file       */
  306.         msg = 'Preferences saved.'        /*     Build success message   */
  307.         end
  308.       else msg = 'Unable to write\'cfgfile/*  Build error message        */
  309.       x = wxy                             /*   Assume year mode          */
  310.       y = wyy
  311.       if mode=='M' then do                /*   Handle month mode         */
  312.         y = mym
  313.         if wxm+wwm<screencols('Workbench') then x = wxm
  314.         else x = wxm-40                   /*     Guard against overflow  */
  315.         end
  316.       call postmsg(x,y,msg)               /*   Post the message          */
  317.       call delay 100                      /*   Wait a couple seconds     */
  318.       call postmsg()                      /*   Clear the message         */
  319.       drop x y msg                        /*   Drop some variables       */
  320.       iterate                             /*   Bypass refresh            */
  321.       end /* SPREF */
  322.     otherwise nop                         /* Ignore unknown actions      */
  323.     end /* select */
  324.   if mode=='M' then call mdates           /* Fill in dates for month     */
  325.   else call ydates                        /* Fill in dates for year      */
  326.   end /* Main control loop */
  327.  
  328. /* Clean up and get out */
  329. syntax: signal off syntax                 /* Clear for next two calls    */
  330. call exit('WACCTL')                       /* Close window, remove host   */
  331. call closeport('WAC')                     /* Close notify port           */
  332. exit                                      /* Ride off into the sunset    */
  333.  
  334. /* Subroutines */
  335. reset:                                    /* Establish current date      */
  336.   parse value date('s') with 1 thisyear +4 5 thismonth +2 7 thisday +2 .
  337.   thismonth = thismonth+0                 /* Drop leading zero on month  */
  338.   thisday = thisday+0                     /* Drop leading zero on day    */
  339.   year = thisyear                         /* Save current year           */
  340.   month = thismonth                       /* Save current month          */
  341.   day = thisday                           /* Save current day            */
  342.   call removehl                           /* Current day may have changed*/
  343.   return
  344.  
  345. mdates:                                   /* Fill in dates for month     */
  346.   call getday                             /* Determine 1st day of month  */
  347.   offset = result                         /* 0=Mo 1=Tu etc.              */
  348.   days = mo_days.month                    /* Get & adjust days in month  */
  349.   if year//4=0 & year>1900 & month=2 then days = days+1
  350.   dates = left(left(' ',offset*3)||substr(dstring,1,days*3-1),125)
  351.   do w = 21 to 105 by 21                  /* Insert \s for new lines     */
  352.     dates = overlay('\',dates,w)
  353.     end
  354.   w = left('\',blanks,'\')               /* Adjust for large font        */
  355.   text = w'\'heading'\'dates             /* Add heading to date string   */
  356.   if year=thisyear & month=thismonth then do /* Handle current month     */
  357.     call windowtext('WACCTL',text)           /*   Write dates            */
  358.     xmin = (offset+(thisday-1))//7*3*xchar+xminb
  359.     ymin = (offset+(thisday-1))%7*ychar+yminbm
  360.     xmax = xmin+xchar*2-1
  361.     ymax = ymin+ychar-1
  362.     call setdrmd('WACCTL','complement')
  363.     call rectfill('WACCTL',xmin,ymin,xmax,ymax)/* Highlight current date */
  364.     call setdrmd('WACCTL','jam1')
  365.     hlsw = 1                              /*      Indicate highlight     */
  366.     end
  367.   else do                                 /* Handle non-current month    */
  368.     call removehl                         /*   Remove highlight if any   */
  369.     call windowtext('WACCTL',text)        /*   Write dates               */
  370.     end
  371.   drop text dates                         /* Drop some variables         */
  372.   return
  373.  
  374. ydates:                                   /* Fill in dates for year      */
  375.   savemonth = month                       /* Save current month          */
  376.   text = left('\',blanks,'\')             /* Clear, adjust for large font*/
  377.   do rx = 0 to 3                          /* Build four rows             */
  378.     line. = ''                            /*   Clear all lines           */
  379.     do month = rx*3+1 to rx*3+3           /*   Build calendar for month  */
  380.       call getday                         /*     Determine 1st day       */
  381.       offset = result                     /*     0 = Mo 1 = Tu etc.      */
  382.       days = mo_days.month                /*     Get & adjust days       */
  383.       if year//4=0 & year>1900 & month=2 then days = days+1
  384.       dates.month = left(left(' ',offset*3)||substr(dstring,1,days*3-1),125)
  385.       line.1 = line.1||centre(mo_name.month,20)'   '  /* Month names     */
  386.       line.2 = line.2||heading'   '                   /* Headings        */
  387.       do lx = 3 to 8                                  /* Dates           */
  388.         line.lx = line.lx||substr(dates.month,(lx-3)*21+1,20)'   '
  389.         end
  390.       end
  391.     do lx = 1 to 8                        /*   Build row from lines      */
  392.       text = text'\'substr(line.lx,1,66)
  393.       end
  394.     if rx<3 then text = text'\'           /*   Add space between rows    */
  395.     end
  396.   if year=thisyear then do                /* Handle current year         */
  397.     month = thismonth                     /*   Set for current month     */
  398.     call windowtext('WACCTL',text)        /*   Write dates               */
  399.     offset = getday()                     /*   Get offset for the month  */
  400.     xmin = (offset+(thisday-1))//7*3*xchar+xminb+mo_x.month
  401.     ymin = (offset+(thisday-1))%7*ychar+yminby+mo_y.month
  402.     xmax = xmin+xchar*2-1
  403.     ymax = ymin+ychar-1
  404.     call setdrmd('WACCTL','complement')
  405.     call rectfill('WACCTL',xmin,ymin,xmax,ymax)/* Highlight current date */
  406.     call setdrmd('WACCTL','jam1')
  407.     hlsw = 1                              /*      Indicate highlight     */
  408.     end
  409.   else do                                 /* Handle non-current year     */
  410.     call removehl                         /*   Remove highlight if any   */
  411.     call windowtext('WACCTL',text)        /*   Write dates               */
  412.     end
  413.   month = savemonth                       /* Restore current month       */
  414.   drop text dates. line. rx lx savemonth  /* Drop some variables         */
  415.   return
  416.  
  417. openw:                                    /* Open a window               */
  418.   if mode=='M' then do                    /* Set for month               */
  419.     w = screencols('Workbench')
  420.     if wxm+wwm<=w then wx = wxm
  421.     else wx = w-wwm
  422.     w = screenrows('Workbench')
  423.     if wym+whm<=w then wy = wym
  424.     else wy = w-whm
  425.     ww = wwm
  426.     wh = whm
  427.     ylx = ylxm
  428.     yly = ylym
  429.     yrx = yrxm
  430.     yry = yrym
  431.     yrw = yrwm
  432.     ymx = ymxm
  433.     ymy = ymym
  434.     end
  435.   else do                                 /* Set for year                */
  436.     w = screencols('Workbench')
  437.     if wxy+wwy<=w then wx = wxy
  438.     else wx = w-wwy
  439.     w = screenrows('Workbench')
  440.     if wyy+wwy<=w then wy = wyy
  441.     else wy = w-why
  442.     ww = wwy
  443.     wh = why
  444.     ylx = ylxy
  445.     yly = ylyy
  446.     yrx = yrxy
  447.     yry = yryy
  448.     yrw = yrwy
  449.     ymx = ymxy
  450.     ymy = ymyy
  451.     end
  452.   call openwindow('WACCTL',wx,wy,ww,wh,idcmp,flags,'WAC')
  453.   call addmenu('WACCTL','WAC     ')
  454.   call additem('WACCTL','Reset        ','reset')
  455.   call additem('WACCTL','Mode','mode')
  456.   call addsubitem('WACCTL','   Month','mmode %f %e',,-1)
  457.   call addsubitem('WACCTL','   Year ','ymode %f %e',,-1)
  458.   call additem('WACCTL','Save prefs   ','spref %f %e')
  459.   call additem('WACCTL','Quit         ','quit')
  460.   call addgadget('WACCTL',ylx,yly,'yless','<','yless')
  461.   call addgadget('WACCTL',yrx,yry,'ystrg',year,'ystrg %g',yrw)
  462.   call addgadget('WACCTL',ymx,ymy,'yless','>','ymore')
  463.   if mode=='Y' then do
  464.     call setitem('WACCTL',0,1,1,'on')
  465.     call ydates                           /* Fill in dates for year      */
  466.     return
  467.     end
  468.   call addgadget('WACCTL',mlx,mly,'mless','<','mless')
  469.   w = left(mo_name.month,9)
  470.   call addgadget('WACCTL',mrx,mry,'mstrg',w,'mstrg %g',mrw)
  471.   call addgadget('WACCTL',mmx,mmy,'mmore','>','mmore')
  472.   call setitem('WACCTL',0,1,0,'on')
  473.   call mdates                             /* Fill in dates for month     */
  474.   return
  475.  
  476. newmonth:                                 /* Re-write month gadget       */
  477.   if mode=='Y' then return                /* If year mode just return    */
  478.   call removegadget('WACCTL','mstrg')     /* Remove old gadget           */
  479.   w = left(mo_name.month,9)
  480.   call addgadget('WACCTL',mrx,mry,'mstrg',w,'mstrg %g',mrw)
  481.   return
  482.  
  483. newyear:                                  /* Re-write year gadget        */
  484.   call removegadget('WACCTL','ystrg')     /* Remove old gadget           */
  485.   call addgadget('WACCTL',yrx,yry,'ystrg',year,'ystrg %g',yrw)
  486.   return
  487.  
  488. removehl:                                 /* Remove highlight            */
  489.   if ~hlsw then return                    /* If no highlight just return */
  490.   call setapen('WACCTL',0)
  491.   call rectfill('WACCTL',xmin,ymin,xmax,ymax) /* Remove highlight        */
  492.   hlsw = 0                                    /* Mark the trail          */
  493.   return
  494.  
  495. getday:                                   /* Get first day of month      */
  496.   w = year-1900
  497.   days = w+(w-1)%4+mo_prev.month
  498.   if year//4=0 & year>1900 & month>2 then days = days+1
  499.   return days//7
  500.  
  501. relative:                                 /* Handle relative date change */
  502.   count = upper(word(message,2))          /* Get desired count           */
  503.   period = upper(word(message,3))         /* Get desired period          */
  504.   if ~datatype(count,'w') then return 0   /* Return if count invalid     */
  505.   if words(period)=0 then period = 'DAYS' /* Default period is DAYS      */
  506.   saveyear = thisyear                     /* Save current settings       */
  507.   savemonth = thismonth
  508.   saveday = thisday
  509.   select
  510.     when abbrev('DAYS',period) then do
  511.       w = thisyear||right(thismonth,2,'0')||right(thisday,2,'0')
  512.       w = date('s',date('i',w,'s')+count,'i')
  513.       thisyear = substr(w,1,4)            /*   Get new year              */
  514.       thismonth = substr(w,5,2)+0         /*   Get new month             */
  515.       thisday = substr(w,7)+0             /*   Get new day               */
  516.       end
  517.     when abbrev('WEEKS',period) then do
  518.       w = thisyear||right(thismonth,2,'0')||right(thisday,2,'0')
  519.       w = date('s',date('i',w,'s')+count*7,'i')
  520.       thisyear = substr(w,1,4)            /*   Get new year              */
  521.       thismonth = substr(w,5,2)+0         /*   Get new month             */
  522.       thisday = substr(w,7)+0             /*   Get new day               */
  523.       end
  524.     when abbrev('MONTHS',period) then do
  525.       w = thisyear*12+thismonth+count     /*   Get total months          */
  526.       thisyear = (w-1)%12                 /*   Get new year              */
  527.       thismonth = w//12                   /*   Get new month             */
  528.       if thismonth=0 then thismonth = 12
  529.       end
  530.     when abbrev('YEARS',period) then ,
  531.       thisyear = thisyear+count           /*   Get new year              */
  532.     otherwise return 0
  533.     end
  534.   if thisyear<1900 | thisyear>2099 then do/* Handle invalid setting      */
  535.     thisyear = saveyear                   /*   Restore saved values      */
  536.     thismonth = savemonth
  537.     thisday = saveday
  538.     return 0
  539.     end
  540.   year = thisyear                         /* Save current year           */
  541.   month = thismonth                       /* Save current month          */
  542.   day = thisday                           /* Save current day            */
  543.   call removehl                           /* Current day has changed     */
  544.   return 1
  545.